perm filename PLTIT.F4[NEW,LCS]1 blob
sn#148540 filedate 1975-02-26 generic text, type T, neo UTF8
00100 C**** PLTCMD, FILLMS, ROTATE ********
00200 SUBROUTINE PLTCMD
00300 CC IMPLICIT INTEGER(A-Q,S-Z)
00400 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /OUTF/JJ
00500 DIMENSION NMS(8),RMOV1(8),RMOV2(8)
00600 COMMON /DL/RSIZ,SAVER,NAME /ALF/INP(72),ML
00700 COMMON R2,JE,CENTR,JB,RJQ(20),JQ(20)
00800 EQUIVALENCE (R5,RJQ(3)),(R6,RJQ(4)),(R7,RJQ(5)),(R4,RJQ(2))
00900 1,(R3,RJQ(1)),(I2,INP(2)),(R8,RJQ(6)),(NMS(1),INP(31))
01000 1,(RMOV1(1),INP(39)),(R9,RJQ(7))
01100 C BE CAREFUL OF COMMON OVERLAPS WITH NOTWRT,ITMSUB,HOMER, ETC.
01200 F78F(1)='(78F)'
01300 FA5(1)='(A5) '
01400 FA1(1)='(A1) '
01500
01600 IF(I2.NE.'X')GO TO 1
01700 I2=0
01800 RXC=0
01900 RMOV1(1)='Y'
02000 NAME=0
02100 14 KA=0
02200 3 KA=KA+1
02300 IF(MLL.EQ.0)GO TO 15
02400 K=K-2
02500 MLL=MLL-1
02600 IF(MLL.EQ.0)GO TO 10
02700 GO TO 31
02800 15 TYPE 2,KA
02900 ACCEPT 11,K,MLL,RSPC
03000 C TYPE LAST NAME, NUMBER FOR A SERIES, 2ND NUM FOR FIXED SPACE ".
03100 50 IF(K.EQ.' ')GO TO 10
03200 IF(K.EQ.'99')GO TO 140
03300 C 99=BACKUP
03400 31 IF(LOOKD(K))GO TO 56
03500 C JUMP IF FILE FOUND
03600 TYPE 55
03700 GO TO 15
03800 55 FORMAT(' FILE NOT FOUND'/)
03900 11 FORMAT(A5,I,F)
04000 56 NMS(KA)=K
04100 IF(MLL.EQ.0)GO TO 5
04200 R8='Y'
04300 IF(RSPC.NE.0)R8=RSPC
04400 GO TO 21
04500 5 TYPE 8
04600 ACCEPT FA5,R8
04700 IF(R8.EQ.'99')GO TO 15
04800 IF(R8.NE.'Y')R8=0
04900 IF(R8.EQ.0)REREAD F78F,R8
05000 C MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
05100 21 RMOV1(KA+1)=R8
05200 RMOV2(KA)=R8
05300 GO TO 3
05400 140 KA=KA-1
05500 GO TO 15
05600
05700 10 KB=KA-1
05800 IF(I3.NE.'G')GO TO 22
05900 RSIZ=1
06000 GO TO 222
06100 22 TYPE 9
06200 ACCEPT F78F,RSIZ,R9
06300 C SET R9 TO 1 FOR HEAVY STAFF LINES (FOR XGP MAINLY)
06400 IF(RSIZ.EQ.99)GO TO 5
06500 IF(RSIZ.EQ.0)GO TO 5
06600 TYPE 550
06700 ACCEPT 11,JJ
06800 550 FORMAT(' TYPE OUTPUT NAME - '$)
06900 222 KA=0
07000
07100 1 IF(NAME.NE.0)GO TO 12
07200 IF(KA.EQ.KB)CALL PLOT(0,0,99)
07300 NAME=NMS(KA+1)
07400 TYPE 111,NAME
07500 RETURN
07600 12 KA=KA+1
07700 NAME=0
07800 R8=0
07900 R2=RSIZ
08000 R3=RSIZ
08100 C FOR FILLER. SIZES .LT. 1.6 = EVERY SCAN LINE, .LT. 2.6 = 2, ETC.
08200 R7=0
08300 R5=1
08400 R6=1
08500 IF(RMOV2(KA).NE.'Y')R7=RMOV2(KA)
08600 IF(RMOV1(KA).NE.0)R5=0
08700 IF(RMOV2(KA).NE.0)GO TO 77
08800 IF(R7.EQ.0)RETURN
08810 77 R6=0
08900 2 FORMAT(' TYPE FILE NAME',I2,1X$)
09000 8 FORMAT(' MOVE UP AT END? ',$)
09100 9 FORMAT(' SIZE FACTOR? ',$)
09200 111 FORMAT(1XA5/)
09300 END
09400
09500
09600
09700 C****** CHANGE 3, 4 AND 5 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
09800 SUBROUTINE FILLMS(L,IDAT,R2,CENTR,R6,R7)
09900 COMMON/DL/RSIZ,SAVER,NAME
10000 COMMON/DST/BB,CC/FLM/X(600)
10100 DIMENSION IDAT(1),NX(600)
10150 EQUIVALENCE (NX,X)
10200 COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJ2
10300 C MD=DISPLAY MP=PLOTTER MX=XGP
10400 DATA M2/2/
10500 DX=DIS
10600 RX=RHT
10700 D=RSTJ2*R6
10800 R=RSTJ2*R7
10900 4 GO TO 1
11000 C=CC
11100 B=BB
11200 C SAVES IT. IT WILL RETURN LATER.
11300 BB=B/DIS
11400 CC=1000
11500 1 KK=-2
11600 DO 205 J=1,L
11650 KK=KK+3
11675 KX=KK+2
11700 CALL UNPACK(M,N,IDAT(J))
11900 NX(KX)=2
12000 IF(LL.EQ.3)NX(KX)=3
12100 X(KK)=ROFF((R2+D*M)*DIS)
12200 X(KK+1)=ROFF((CENTR+R*N)*RHT)
12300 3 GO TO 205
12400 X(KK+1)=X(KK+1)*(C-BB*(ABS(X(KK))))
12500 C FOR DISTORTION
12600 205 CONTINUE
12700 NX(3)=KX
12800 DIS=1.0
12900 RHT=DIS
13000 IF(IPLT)M=RSIZ+.4
13100 IF(M.LE.0)M=1
13200 IF(M.GT.M2)M=M2
13300 C STOPS DISTORTION IN 'LINES'
13400 2 CALL FILLER(NX,M)
13500 DIS=DX
13600 RHT=RX
13700 5 RETURN
13800 C NEXT TO RESET DISTORTION FACT.
13900 BB=B
14000 CC=C
14100 RETURN
14200 END
14300
14400 SUBROUTINE ROTATE(I,L)
14500 DIMENSION I(1)
14600 COMMON R2,JA,CENTR,JB,RJQ(20),JQ(20)/STF/RR(8),RSTJ2
14700 EQUIVALENCE (R6,RJQ(4)),(R7,RJQ(5)),(DEG,RJQ(7))
14800 R7=R7*RSTJ2
14900 R6=R6*RSTJ2
15000 N=I(L)
15100 KNT=601
15200 C ROTATED DATA IS PUT BACK STARTING AT LOCATION 601.
15300 I(KNT)=N
15400 DO 1 K=L+1,N+L-1
15500 CALL UNPACK(J,M,I(K))
15600 X=J*R6
15700 Y=M*R7
15800 JJ=I(K)/100000000
15900 AX=ATAN2(X,Y)*57.29578
16000 HYP=SQRT(X**2+Y**2)
16100 ROT=DEG+AX
16200 J=ROFF(HYP*COSD(ROT))
16300 M=ROFF(HYP*SIND(ROT))
16400 KNT=KNT+1
16500 IF(J)J=1000-J
16600 IF(M)M=1000-M
16700 1 I(KNT)=M*10000+J+JJ*100000000
16800 L=601
16900 R6=1.
17000 R7=1.
17100 RSTJ2=1.
17200 C SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
17300 END
17400
17500 CC SUBROUTINE PLOT(J,K,L)
17600 CC CALL PLOTX(J,K,L)
17700 CC END
17800 C TO ROTATE 90 DEG. CHANGE IN DDT AT 1M - 'JUMP J' TO 'JUMP K' AND VS-VS.
17900
18000 SUBROUTINE PLOT(I,J,K)
18100 COMMON /OUTF/JJ
18200 DIMENSION N(128)
18300 IF(JJ.EQ.-1)GO TO 4
18400 L=1
18500 N(1)=127
18600 IF(JJ.EQ.' ')JJ='PLT'
18700 CALL PUTFIL(JJ)
18800 JJ=-1
18900 4 IF(K.EQ.99)GO TO 1
19000 L=L+1
19100 CALL PAC(N(L),I)
19200 CC N(L)=J+5000+(I+5000)*10000+(K+4)*100000000
19300 C PACKS PX000Y000
19400 3 IF(L.LT.128)RETURN
19500 2 CALL FASTOU(N,128)
19600 L=1
19700 RETURN
19800 1 N(1)=L
19900 J=N(L)
20000 DO 100 JJ=L,128
20100 100 N(JJ)=J
20200 CALL FASTOU(N,128)
20300 CALL FINFIL
20400 JJ=0
20500 CALL EXIT
20600 END
20700
20800 SUBROUTINE PLOTS(K)
20900 C DUMMY
21000 END